;; -*-Package:HACKS; Mode:LISP; Base: 8-*-

(DEFFLAVOR FOM-MIXIN () ()
  (:INCLUDED-FLAVORS TV:SHEET))

(DEFVAR FOM-ARRAY (MAKE-PIXEL-ARRAY 1100 706 ':TYPE 'ART-4B))

(DEFUN READ-FOM (&OPTIONAL (FILE-NAME "SYS:DEMO;RISING SUN >"))
  (WITH-OPEN-FILE (FILE FILE-NAME '(READ FIXNUM))
    (LOOP FOR X FROM 0 TO 600
          DO (LOOP FOR Y FROM 519. DOWNTO -120. BY 2
                   DO (LET ((WORD (FUNCALL FILE 'TYI)))
                        (COND ((AND (< Y 453.) ( Y 0))
                               (AS-2-REVERSE (LDB 1404 WORD) FOM-ARRAY X Y)
                               (AS-2-REVERSE (LDB 0404 WORD) FOM-ARRAY X (1+ Y)))))))))

(DEFFLAVOR FOM () (FOM-MIXIN TV:WINDOW)
  (:DEFAULT-INIT-PLIST :LABEL NIL :BLINKER-P NIL :SAVE-BITS T))

(DEFMETHOD (FOM :NAME-FOR-SELECTION) () NIL)

(DEFMETHOD (FOM :AFTER :REFRESH) (&OPTIONAL TYPE)
  (AND (OR (NOT TV:RESTORED-BITS-P) (EQ TYPE ':SIZE-CHANGED))
       (TV:SHEET-FORCE-ACCESS (SELF)
         (FUNCALL-SELF ':BITBLT TV:ALU-SETA (TV:SHEET-INSIDE-WIDTH) (TV:SHEET-INSIDE-HEIGHT)
                       FOM-ARRAY (IF (> (TV:SHEET-INSIDE-WIDTH) 600) 0
                                     (// (- 600 (TV:SHEET-INSIDE-WIDTH)) 2))
                                 (// 706 (TV:SHEET-INSIDE-HEIGHT))
                       0 0))))

(DEFVAR FOM-WINDOW (TV:MAKE-WINDOW 'FOM ':SUPERIOR COLOR:COLOR-SCREEN))

(DEFUN SETUP-FOM ()
  (COLOR:GRAY-COLOR-MAP)
  (TV:WITH-SHEET-DEEXPOSED (FOM-WINDOW)
    (TV:SHEET-FORCE-ACCESS (FOM-WINDOW)
      (FUNCALL FOM-WINDOW ':REFRESH)))
  (FUNCALL FOM-WINDOW ':EXPOSE))

;;; Lunar turkey (actually, any window)
(DEFVAR RECT-HEIGHT)
(DEFVAR RECT-WIDTH)
(DEFVAR TURKEY-WINDOW)
(DEFVAR HOLE-X)
(DEFVAR HOLE-Y)
(DEFUN TURKEY (&OPTIONAL (WINDOW FOM-WINDOW) (NUMBER-HORIZONTAL 4) (NUMBER-VERTICAL 4))
  (LET ((RECT-HEIGHT (// (TV:SHEET-INSIDE-HEIGHT WINDOW) NUMBER-VERTICAL))
        (RECT-WIDTH (// (TV:SHEET-INSIDE-WIDTH WINDOW) NUMBER-HORIZONTAL))
        (HOLE-X 0) (HOLE-Y 0)
        (TURKEY-WINDOW WINDOW))
    (FUNCALL WINDOW ':DRAW-RECTANGLE (- (TV:SHEET-INSIDE-WIDTH WINDOW)
                                        (* RECT-WIDTH NUMBER-HORIZONTAL))
             (TV:SHEET-INSIDE-HEIGHT WINDOW)
             (* RECT-WIDTH NUMBER-HORIZONTAL) 0
             (TV:SHEET-ERASE-ALUF WINDOW))
    (FUNCALL WINDOW ':DRAW-RECTANGLE (TV:SHEET-INSIDE-WIDTH WINDOW)
             (- (TV:SHEET-INSIDE-HEIGHT WINDOW)
                (* RECT-HEIGHT NUMBER-VERTICAL))
             0 (* RECT-HEIGHT NUMBER-VERTICAL)
             (TV:SHEET-ERASE-ALUF WINDOW))
    (ERASE-SQUARE 0 0)
    (LET ((LAST-MOVE -1))
      (DOTIMES (I (+ 30 (RANDOM 20)))
        (DO ((X HOLE-X HOLE-X)
             (Y HOLE-Y HOLE-Y)
             (MOVE))
            (())
          (SELECTQ (SETQ MOVE (RANDOM 4))
            (0 (SETQ X (1+ X)))
            (1 (SETQ Y (1+ Y)))
            (2 (SETQ X (1- X)))
            (3 (SETQ Y (1- Y))))
          (COND ((AND ( X 0) ( Y 0) (< X NUMBER-HORIZONTAL) (< Y NUMBER-VERTICAL)
                      ( MOVE
                         (CDR (ASSQ LAST-MOVE '((-1 . -1) (0 . 2) (1 . 3) (2 . 0) (3 . 1))))))
                 (MOVE-SQUARE X Y HOLE-X HOLE-Y)
                 (SETQ HOLE-X X
                       HOLE-Y Y)
                 (SETQ LAST-MOVE MOVE)
                 (RETURN))))))
    (PLAY-GAME)))

(DEFUN ERASE-SQUARE (SX SY)
  (FUNCALL TURKEY-WINDOW ':DRAW-RECTANGLE RECT-WIDTH RECT-HEIGHT
           (* RECT-WIDTH SX) (* RECT-HEIGHT SY)
           (TV:SHEET-CHAR-ALUF TURKEY-WINDOW)))

(DEFCONST TURKEY-NUMBER-OF-MOVES 10.)
(DEFCONST TURKEY-SLEEP 0)
(DEFUN MOVE-SQUARE (FX FY TX TY)
  (SETQ FX (* FX RECT-WIDTH)
        FY (* FY RECT-HEIGHT)
        TX (* TX RECT-WIDTH)
        TY (* TY RECT-HEIGHT))
  (LET ((DX (// (- TX FX) TURKEY-NUMBER-OF-MOVES))
        (DY (// (- TY FY) TURKEY-NUMBER-OF-MOVES)))
    (DO ((X FX NX)
         (Y FY NY)
         (NX) (NY)
         (I (1- TURKEY-NUMBER-OF-MOVES) (1- I)))
        ((< I 0))
      (FUNCALL TURKEY-WINDOW ':BITBLT-WITHIN-SHEET TV:ALU-SETA
               (IF (< DX 0) RECT-WIDTH (- RECT-WIDTH))
               (IF (< DY 0) RECT-HEIGHT (- RECT-HEIGHT))
               X Y
               (SETQ NX (IF (= I 0) TX (+ X DX)))
               (SETQ NY (IF (= I 0) TY (+ Y DY))))
      (FUNCALL TURKEY-WINDOW ':DRAW-RECTANGLE
               (IF (= DX 0) RECT-WIDTH (ABS (- NX X)))
               (IF (= DY 0) RECT-HEIGHT (ABS (- NY Y)))
               (COND ((= DX 0) X)
                     ((< DX 0) (+ NX RECT-WIDTH))
                     (T X))
               (COND ((= DY 0) Y)
                     ((< DY 0) (+ NY RECT-HEIGHT))
                     (T Y))
               (TV:SHEET-CHAR-ALUF TURKEY-WINDOW))
      (PROCESS-SLEEP TURKEY-SLEEP))))

(DEFUN PLAY-GAME (&AUX (OLD-MOUSE-SHEET TV:MOUSE-SHEET))
  (UNWIND-PROTECT
    (PROGN
      (TV:MOUSE-SET-SHEET TURKEY-WINDOW)
      (TV:WITH-MOUSE-GRABBED
        (DO () (())
          (PROCESS-WAIT "Turkey Mouse" #'(LAMBDA () ( TV:MOUSE-LAST-BUTTONS 0)))
          (AND (BIT-TEST TV:MOUSE-LAST-BUTTONS 4) (RETURN))
          (LET ((SX (// (- TV:MOUSE-X (TV:SHEET-INSIDE-LEFT TURKEY-WINDOW)) RECT-WIDTH))
                (SY (// (- TV:MOUSE-Y (TV:SHEET-INSIDE-TOP TURKEY-WINDOW)) RECT-HEIGHT)))
            (COND ((OR (AND (= SX HOLE-X) (= 1 (ABS (- SY HOLE-Y))))
                       (AND (= SY HOLE-Y) (= 1 (ABS (- SX HOLE-X)))))
                   (MOVE-SQUARE SX SY HOLE-X HOLE-Y)
                   (SETQ HOLE-X SX
                         HOLE-Y SY))
                  (T (TV:BEEP))))
          (PROCESS-WAIT "Turkey off the mouse" #'(LAMBDA () (ZEROP TV:MOUSE-LAST-BUTTONS))))))
    (TV:MOUSE-SET-SHEET OLD-MOUSE-SHEET)))
